#!/usr/bin/perl -w

#------------------------------------------------------------------------------
# Author:  Marelie Davel (marelie.davel@gmail.com
#------------------------------------------------------------------------------

use strict;
use warnings;

#------------------------------------------------------------------------------

sub print_usage() {
  print "       analyse.pl rules <in.rules> <in.symbols> <in.basic> <out.analysis>\n";
  print "       analyse.pl predict_alt <word> <in.rules> <in.symbols>\n";
  print "       analyse.pl predict_alt_list <in.list> <in.rules> <in.symbols> <out>\n";
  print "       analyse.pl predict_best_list <in.list> <in.rules> <in.symbols> <out.result>\n";
  print "       analyse.pl compare_acc <in.list1> <in.list2> <out.result>\n";
  print "       analyse.pl combine_results <in.prefix> <out.summary>\n";
}

#------------------------------------------------------------------------------
# Helper functions
#------------------------------------------------------------------------------

sub fread_rules($\%\@) {
  my ($rulesName,$symbolsP,$ruleP)=@_;
  open my $rules, '<:encoding(utf8)', $rulesName or die "Cannot open $rulesName";
  @$ruleP=();
  while (<$rules>) {
    chomp;
    my @parts = split /;/;
    if (scalar @parts != 6) {
      die "Error: rule file format error: $_\n";
    }
    my $class = $parts[3];
    if (!(exists $symbolsP->{$class})) {
      die "Error: unknown symbol $class\n";
    }
    my $rule = sprintf "%s:%s",$parts[1],$symbolsP->{$class};
    push @$ruleP, $rule;
  }
  close $rules;
}

#--------------------------------------------------------

sub fread_symbols($\%) {
  my ($symName,$symbolP)=@_;
  open my $symbols, '<:encoding(utf8)', $symName or die "Cannot open $symName";
  %$symbolP=();
  while (<$symbols>) {
    chomp;
    my @parts = split /\t/;
    if (scalar @parts != 2) {
      die "Error: symbol file format error: $_\n";
    }
    $symbolP->{$parts[1]}=$parts[0];
  }
  close $symbols;
}

sub rewrite($) {
  my $instr = shift @_;
  $instr =~ s/#/ /g;
  $instr =~ s/@/'/g;
  $instr =~ s/%/-/g;
  return $instr;
}


#------------------------------------------------------------------------------
# Main functionality
#------------------------------------------------------------------------------

sub do_analyse($$$$) {
  my ($inName,$symName,$instName, $outName) = @_;
  open my $in, '<:encoding(utf8)', $inName or die "Cannot open $inName";
  open my $symbols, '<:encoding(utf8)', $symName or die "Cannot open $symName";
  open my $instances, '<:encoding(utf8)', $instName or die "Cannot open $instName";
  open my $out, '>:encoding(utf8)', $outName or die "Cannot open $outName";

  #Read symbol file
  my %sList=();
  while (<$symbols>) {
    chomp;
    my @parts = split /\t/;
    if (scalar @parts != 2) {
      die "Error: symbol file format error: $_\n";
    }
    $sList{$parts[1]}=$parts[0];
  }

  #Read instances file
  my %iList=();
  my %iClassList=();
  while (<$instances>) {
    chomp;
    my @parts = split /\t/;
    if (scalar @parts != 3) {
      die "Error: instances file format error: $_\n";
    }
    $iList{$parts[0]}=$parts[2];
    $iClassList{$parts[0]}=$parts[1];
  }

  #Analyse rules file
  while (<$in>) {
    chomp;
    my @parts = split /;/;
    if (scalar @parts != 6) {
      die "Error: rule file format error: $_\n";
    }
    my $class = $parts[3];
    if (!(exists $sList{$class})) {
      die "Error: unknown symbol $class\n";
    }
    my $rule = $parts[1];
    printf $out "---------------------------------\n";
    printf $out "Rule %d:\t[%s]\t[%s]\t[%d nett instances]\n",$parts[4],rewrite($rule),rewrite($sList{$class}),$parts[5];
    printf $out "Examples:\n";
    foreach my $i (sort keys %iList) {
      my $start = length($i)-length($rule);
      if (index($i,$rule,$start)>-1) {
        if ($sList{$class} eq $iClassList{$i}) {
          printf $out "%s->%s\n",rewrite($i),rewrite($iList{$i});
        }
      }
    }
    print $out "\n";
  }
  close $in;
  close $out;
  close $symbols;
}

#--------------------------------------------------------

sub find_alts($\@\@) {
  my ($word,$rulesP,$altP) = @_;
  my $ri;
  my $alt;
  for ($ri=$#$rulesP;$ri--;0) {
    my ($rule,$class) = split /:/,$rulesP->[$ri];
    if ($word =~ /$rule$/) {
      if ($class =~ /R(.*)>/) {
        my $wordEnd = $1;
        if ($word =~ /$wordEnd$/) {
          $alt = sprintf "%s\t(%d)",$class,$ri;
          push @$altP,$alt;
        }
      } else {
        $alt = sprintf "%s\t(%d)",$class,$ri;
        push @$altP,$alt;
      }
    }
  }
}

#--------------------------------------------------------

sub do_alt($$$) {
  my ($word,$rulesName,$symName)=@_;
  my @rList=();
  my %sList=();
  my @alts=();
  fread_symbols($symName,%sList);  
  fread_rules($rulesName,%sList,@rList);
  find_alts($word,@rList,@alts);
  print "Alternatives for $word:\n";
  foreach my $a (@alts) {
    printf "%s\n", rewrite($a);
  }
}

#--------------------------------------------------------

sub do_alt_list($$$$) {
  my ($inName,$rulesName,$symName,$outName)=@_;
  open my $in, '<:encoding(utf8)', $inName or die "Cannot open $inName";
  open my $out, '>:encoding(utf8)', $outName or die "Cannot open $outName";

  my @rList=();
  my %sList=();
  fread_symbols($symName,%sList);  
  fread_rules($rulesName,%sList,@rList);

  while (<$in>){
    chomp;
    my @alts=();
    find_alts($_,@rList,@alts);
    print $out "Alternatives for $_:\n";
    foreach my $a (@alts) {
      printf "%s\n", rewrite($a);
    }
  }
  close $in;
  close $out;
}

sub do_predict_file($$$$) {
  my ($inName,$rulesName,$symName,$outName)=@_;
  open my $in, '<:encoding(utf8)', $inName or die "Cannot open $inName";
  open my $out, '>:encoding(utf8)', $outName or die "Cannot open $outName";

  my @rList=();
  my %sList=();
  fread_symbols($symName,%sList);  
  fread_rules($rulesName,%sList,@rList);

  while (<$in>){
    chomp;
    my @alts=();
    find_alts($_,@rList,@alts);
    my $classID = $alts[0];
    $classID =~ s/([a-z\)])\s+\([0-9]*\)/$1/;
    printf $out "%s\t%s\n",rewrite($_),rewrite($classID);
  }
  close $in;
  close $out;
}


sub do_compare_acc($$$) {
  my ($inName1,$inName2,$outName)=@_;
  open my $in1, '<:encoding(utf8)', $inName1 or die "Cannot open $inName1";
  open my $in2, '<:encoding(utf8)', $inName2 or die "Cannot open $inName2";
  open my $out, '>:encoding(utf8)', $outName or die "Cannot open $outName";

  my %inList1=();
  my %inList2=();
  while (<$in1>){
    chomp;
    my @parts = split("\t",$_);
    if (scalar @parts < 2) {
      die "Error with file format, line: $_";
    }
    $inList1{$parts[0]}=$parts[1];
  }
  close $in1;

  while (<$in2>){
    chomp;
    my @parts = split("\t",$_);
    if (scalar @parts < 2) {
      die "Error with file format, line: $_";
    }
    $inList2{$parts[0]}=$parts[1];
  }
  close $in2;

  my %correct = ();
  my %errors = ();
  foreach my $name (keys %inList1) {
    if (!exists $inList2{$name}) {
      printf "Warning: $name not counted, not in second list\n";
    } else {
      if ($inList1{$name} eq $inList2{$name}) {
        $correct{$name}=1;
      } else {
        $errors{$name}=1;
      }
    }
  }
  my $numCorrect = scalar keys %correct;
  my $numError = scalar keys %errors;
  my $numTotal = $numCorrect+$numError;
  printf $out "Accuracy:\t%.2f\n",100.0*$numCorrect/$numTotal;
  printf $out "Correct: \t%d\n",$numCorrect;
  printf $out "Errors:  \t%d\n",$numError;
  foreach my $err (sort keys %errors) {
    printf $out "%s\t%s\t%s\n",$err,$inList1{$err},$inList2{$err}; 
  }
  close $out
}


sub do_combine_results($$) {
  my ($inPrefix,$outName)=@_;
  open my $out, '>:encoding(utf8)', $outName or die "Cannot open $outName";
  my $accTotal=0;
  foreach my $n (0..9) {
    my $inName = "$inPrefix.$n";
    my $acc = `grep "Accuracy" $inName`;
    chomp $acc;
    $acc =~ s/Accuracy:\s+([0-9]+.[0-9]+$)/$1/;
    printf $out "$n:\t$acc\n";
    $accTotal=$accTotal+$acc;
  }
  $accTotal=$accTotal/10.0;
  printf $out "[cv]:\t%.2f\n",$accTotal;
}

#------------------------------------------------------------------------------

if (scalar @ARGV < 3) {
  print_usage();
  exit;
} elsif (($ARGV[0] eq "rules")&&(scalar @ARGV==5)) {
  do_analyse($ARGV[1],$ARGV[2],$ARGV[3],$ARGV[4]);
} elsif (($ARGV[0] eq "predict_alt")&&(scalar @ARGV==4)) {
  do_alt($ARGV[1],$ARGV[2],$ARGV[3]);
} elsif (($ARGV[0] eq "predict_alt_list")&&(scalar @ARGV==5)) {
  do_alt_list($ARGV[1],$ARGV[2],$ARGV[3],$ARGV[4]);
} elsif (($ARGV[0] eq "predict_best_list")&&(scalar @ARGV==5)) {
  do_predict_file($ARGV[1],$ARGV[2],$ARGV[3],$ARGV[4]);
} elsif (($ARGV[0] eq "compare_acc")&&(scalar @ARGV==4)) {
  do_compare_acc($ARGV[1],$ARGV[2],$ARGV[3]);
} elsif (($ARGV[0] eq "combine_results")&&(scalar @ARGV==3)) {
  do_combine_results($ARGV[1],$ARGV[2]);
} else {
  print_usage();
  exit;
}

#------------------------------------------------------------------------------
